home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / yerk / mps231ss.hqx / Mops source / Module source / Instlmod.txt < prev    next >
Text File  |  1993-03-13  |  14KB  |  498 lines
  1. \ Install - Mops version.
  2. \ July 90        Save nucleus implemented.
  3. \ Sept 90        Necessary mod for our new "startup" CODE resource.
  4. \ Oct 91        Changed to view/window+.
  5. \ May 92        Changed vscroll objects according to "new way" for controls.
  6.  
  7. need    window+
  8.  
  9. konst resLocked        constant    LOCKED
  10. konst resPurgeable    constant    PURGEABLE
  11.  
  12.     0    value        CURSTACK
  13.     0    value        CURDICT
  14.  
  15.     0    value        HEAPAVAIL
  16. false    value        GOTFREE?
  17. true    value        SAVE?
  18.  
  19.     0    value        QUITWORD
  20.     0    value        ABORTWORD
  21.  
  22.     string+        $TMP
  23.  
  24.     int        APREFNUM
  25.     var        APPARAM
  26.  
  27.     21    dialog        IDLG
  28.  
  29. : NOGO    3 beep  3 beep  close: iDlg  set: fWind
  30.     cr ." Res error# " .
  31.     cr ." Type any key to return to Finder, hopefully"
  32.     key  bye  ;
  33.  
  34. : CHK    word0  call reserror  i->l  ?dup
  35.     IF  nogo  THEN  ;
  36.  
  37. ' null    vect    TEMP
  38.  
  39. : ONERROR        \ ( errCfa -- )
  40.         \ Here we temporarily set the error vectors.  This is normally
  41.         \ illegal since we're in a module and the vectors are not.  But
  42.         \ we're safe here, so we kludge it.
  43.     -> temp        \ Store to an internal vect, convert to reloc
  44.     ['] temp @  dup  ['] abortvec !  ['] dflt-die !  ;
  45.  
  46. \ Class RES+ adds methods to Resource to allow various modifications
  47. \ to resources.  We'll put more in as we need them.
  48.  
  49. :class    RES+    super{ resource }
  50.  
  51. objPtr    TEMPRES  class_is  res+
  52.  
  53. :m CHANGED:    get: self  call ChangedResource  ;m
  54.  
  55. :m ADDRES:  { s255 -- }
  56.     get: self
  57.     get: type  get: ID  makeint
  58.     s255  call AddResource  chk  ;m
  59.  
  60. :m CHANGETO:    \ ( res -- )
  61.     -> tempRes
  62.     get: tempRes  dup  call DetachResource  put: self  ;m
  63.  
  64. :m SETATTRS:    \ ( n -- )
  65.     get: self  swap  makeint  call SetResAttrs  chk
  66.     changed: self  ;m
  67.  
  68. ;class
  69.  
  70.     res+    SRCRES
  71.     res+    DSTRES
  72.  
  73. : COPYRES        \ ( type resID -- )  Copies the resource by copying
  74.         \  the handle's data in memory.  Use this one for resources
  75.         \  currently in use.
  76.     2dup  set: srcRes  set: dstRes
  77.     getnew: srcRes  chk  srcRes ->: dstRes
  78.     nullOSstr  addRes: dstRes  chk  ;
  79.  
  80. : CHANGERES    \ ( type resID -- )  Copies the resource by detaching its
  81.         \  handle and attaching it to the new resource.  Use this
  82.         \  one for resources not in use - it has less overhead.
  83.     2dup  set: srcRes  set: dstRes
  84.     getnew: srcRes  chk  srcRes changeTo: dstRes
  85.     nullOSstr  addRes: dstRes  chk  ;
  86.  
  87. : !STACK    curStack -> stkSpace  ;
  88.  
  89. : @HEAP        \ Returns starting heap size for this nucleus.
  90.     gotFree?  NIF  free  -> heapAvail  true -> gotFree?  THEN
  91.     heapAvail  ;
  92.  
  93. : CURHEAP        \ Computes amount of heap available for current configuration.
  94.     @heap  stkspace curStack - +  room curDict - +  ;
  95.  
  96. : SETMEM        \ Sets nucleus stack to selected values
  97.     !stack
  98.     curDict -> maxdic  ;
  99.  
  100. : iMsg        \ ( addr1 len1 addr2 len2 -- )  Gives informatory message
  101.     "  " "  " ParamText draw: iDlg  ;
  102.  
  103. : ChR        \ ( handle -- handle )  Marks the resource for update to disk
  104.     dup call ChangedResource  ;
  105.  
  106. objPtr    theMod  class_is  module
  107. handle    ModHdl
  108.  
  109. : (ADDMOD)  { theCfa n \ ID -- }
  110.     theCfa mod?  NIF  drop  EXIT  THEN
  111.     >obj -> theMod
  112.     install?: theMod  0EXIT    \ Out if not to install this mod
  113.     " module:"  theCfa >name n>count  iMsg
  114.  
  115.         binName: theMod  name: fFcb  0 setVref: fFcb
  116.         openReadOnly: fFcb  ?error 138
  117.         size: fFcb  dup  new: modHdl
  118.         lock: modHdl            \ Maybe we need this
  119.         ptr: modHdl  swap  read: fFcb
  120.         unlock: modHdl        \ Unlock before error check
  121.         close: fFcb  drop  ?error 141
  122.  
  123. \    release: theMod   load: theMod
  124.     word0 'type CODE  call UniqueID  i->l  -> ID
  125.     'type CODE  ID  set: dstRes  ID  setResID: theMod
  126.     ( handle: theMod )  get: modHdl  put: dstRes
  127.     theCfa >name n>count str255  addRes: dstRes
  128.             \ NOTE: we don't release modHdl since it's the
  129.             \ Resource Manager's baby now.
  130.     locked purgeable or  setAttrs: dstRes  ;
  131.  
  132. : ADDMODS
  133.     "  " 2dup 2dup 2dup  paramText
  134.     " Installing ^0 ^1" 21 putText: iDlg
  135.     ['] (addmod)  0  trav  ;
  136.  
  137. : INVWORD        \ ( item# -- )
  138.     40 beep 0 $ ffff rot  setSelect: iDlg  ReturnToModal  ;
  139.  
  140. :a OK        \ Validates quits & abort words; if bad returns to modal
  141.     10 getText: iDlg  sFind  NIF  10 invWord  EXIT  THEN
  142.     -> quitword
  143.     11 getText: iDlg  sFind  NIF  11 invWord  EXIT  THEN
  144.     -> abortword
  145.     true  ;a
  146.  
  147. :a CANCEL    false  ;a
  148.  
  149. cfas{    ok cancel null null null null null null null null null
  150.     togitem togItem togItem null null null null null null null }
  151. 111  init: iDlg   1  setBold: iDlg
  152.  
  153. : GETR
  154.     get_appl_name ->: $tmp  all: $tmp  5  putText: iDlg
  155.     get_appl_vers ->: $tmp  all: $tmp  4  putText: iDlg
  156.     get_appl_sig  pad !  pad 4  3  putText: iDlg  ;
  157.  
  158. : DROP@        \ ( addr len -- addr' )
  159.         \ Fetches 1st four bytes on an odd byte, pad with blanks
  160.     >r sp@ $ 20202020 rot rot r> 4 min cmove  ;
  161.  
  162. : SETFREF        \ ( type n -- )
  163.     'type FREF  swap  set: srcRes  getNew: srcRes
  164.     get: srcRes  ChR  >ptr !  ;
  165.  
  166.  
  167. :class    SETUPHDR    super{ object }
  168.         \ A dummy class to map the info area at the start of the
  169.         \  Setup segment
  170.     var        dummy
  171.     int        &bra        \ The names are the same, with & in front
  172.     var        &maxDic
  173.     var        &minHeap
  174.     var        &dicSize
  175.     var        &StkSpace
  176.     var        &RstkSpace
  177.     bool    &installed
  178.     byte    spare
  179.     int        &nop
  180.  
  181. :m SETUP:  { instld? -- }
  182.  
  183. \    $ a9ff      put: &nop            \ Include to breakpoint on run
  184.  
  185.     maxDic        put: &maxDic
  186.     minHeap        put: &minHeap
  187.     stkSpace    put: &stkSpace
  188.     RstkSpace    put: &RstkSpace
  189.     instld?        put: &installed  ;m
  190. ;class
  191.  
  192. : SETDIC&HEAP        \ ( instld? -- )
  193.     ptr: dstRes  setup: setupHdr  ;     \ Forced bind to pseudo-object
  194.  
  195. : SETAPPLSIZE
  196.     here  nptr: srcRes  -        \ Offset to Here
  197.     curDict +  setSize: dstRes  ;
  198.  
  199. : UNPATCH  { \ ^br -- }
  200.     brs -> ^br
  201.     ^br @    ['] *  6 +    !    4 ++> ^br        \ ***NOTE: add the 6 for words
  202.     ^br @    ['] /  6 +    !    4 ++> ^br        \ with "xinfo" optimization info
  203.     ^br @    ['] mod    !    4 ++> ^br
  204.     ^br @    ['] /mod    !    4 ++> ^br
  205.     ^br @    ['] u/mod    !    4 ++> ^br
  206.     ^br @    ['] mulx    !  ;
  207.  
  208. : ADDCODE        \ Adds the CODE resources to a new application.
  209.  
  210.     " dictionary" "  "  iMsg
  211.  
  212.     'type CODE  0  copyRes            \ Copy CODE 0 (Jump table)
  213.       locked  setAttrs: dstRes
  214.     'type CODE  1  changeRes        \ And CODE 1 (Setup)
  215.       purgeable  setAttrs: dstRes
  216.     true  setDic&heap
  217. \ Now we set all the various flags and vectors appropriately:
  218.     unpatch
  219.     false -> initzed?  true -> instld?
  220.     false -> MRopen?  false -> use_paths?
  221.     0 -> CPaddr
  222.     classinit: fWind  clear: fFcb
  223.     0 -> actW  ['] appInit -> objinit
  224.     quitword -> quitvec
  225.     abortword dup -> abortvec  dup -> dflt-die  -> setFwind
  226.             \ Catch all the possibilities!
  227.             \ Note: we still have to PURGE modules in the dictionary.
  228.             \ We leave this to the last moment as some are still in use.
  229.     'type CODE  2  ChangeRes        \ Copy CODE 2 (main dictionary)
  230.     locked purgeable or  setAttrs: dstRes
  231.     setApplSize  ;
  232.  
  233. : SAVECODE  { \ addr len -- }    \ Copies the CODE resources for
  234.                                 \  a Saved nuc.
  235.     'type CODE  0  copyRes        \ Copy CODE 0 (Jump table)
  236.       locked  setAttrs: dstRes
  237.     'type CODE  3  changeRes        \ And CODE 3 (Handlers)
  238.       purgeable  setAttrs: dstRes
  239.     'type CODE  1  changeRes        \ And CODE 1 (Setup)
  240.       purgeable  setAttrs: dstRes
  241.     false  setDic&heap
  242. \ Last but not least, we'll copy CODE 2 (the main dictionary).
  243. \ First we set all the various flags and vectors appropriately:
  244.     unpatch
  245.     false -> initzed?  0 -> ExBoffs  +curs
  246.     false -> MRopen?  true -> use_paths?
  247.     0 -> CPaddr
  248.     classinit: fWind  true -> fWind?  clear: fFcb
  249.     0 -> uFind  0 -> key  0 -> key!
  250.     0 -> pause  0 -> getSpace
  251.     0 -> rngErr 0 -> $err
  252.     0 -> objinit    0 -> extra_inits
  253.     0 -> abortvec    0 -> setfWind    0 -> dflt-die
  254.     0 -> modload    0 -> TEidle    0 -> compinline
  255.     0 -> actW
  256. \ Whew!  And to think, I found most of those by trial and error!!
  257.  
  258.     'type CODE  2  ChangeRes    \ Yes, I know it's in use, but it's
  259.                     \  OK as we're going to quit
  260.                     \  straight away!
  261.  
  262.     purgeable  setAttrs: dstRes    \ Note: we don't set it locked since
  263.                     \  the Setup segment will resize it
  264.                     \  before moving it high, locking and
  265.                     \  calling it.
  266.     ['] echo? >link (forget)
  267.     here  nptr: srcRes  -        \ Offset to Here
  268.     setSize: dstRes  ;
  269.  
  270. scon    $ALQ    "alert%"    & %  & "  instead
  271.  
  272. : NEW_APPLICATION  { \ sig addr len -- }
  273.         \ This word does all the hard work of creating the
  274.         \ installed application file.
  275.     ['] nogo  onError
  276.     5 getText: iDlg  -> len -> addr
  277.     addr len  name: fFcb
  278.     delete: fFcb  drop            \ Delete any duplicate file
  279.     addr len str255
  280.     call CreateResFile  chk        \ Create new res file for applicn
  281.     0  buf255  call OpenResFile  drop  chk
  282.     3  getText: iDlg  drop@ -> sig    \ New sig
  283.     'type APPL  sig  set: fFcb        \ Set type & sig of appl
  284.     $ 21  fFcb $ 28 + c!            \ Set Bundle bit
  285.     setFileInfo: fFcb
  286.     addMods                    \ Copy chosen modules
  287.     addCode                    \ and CODE 0, 1 and 2
  288.     ['] nogo  onError
  289.     13 getitem: iDlg
  290.     if    true -> fWind?            \ fWind? wanted - copy it (WIND 256)
  291.         'type WIND  256  copyRes
  292.         12 getitem: iDlg  8 <<  ptr: dstRes 10 + w!
  293.                         \ Mark visible or not
  294.     else    false -> fWind?
  295.     then
  296.     'type SIZE  -1   copyRes        \ Copy SIZE -1
  297.     'type BNDL  128  copyRes        \ and don't drop our BNDL (128)
  298.     sig  ptr: dstRes  !            \ Store in new BNDL
  299. \ Now set up FREFs:
  300.     'type FREF  128  copyRes        \ FREF for APPL - doesn't change
  301.     10 6 do                \ FREFs 129 onwards
  302.         i getText: iDlg  dup  nif  drop  leave  then
  303.         'type FREF  123 i +  copyRes
  304.         drop@  ptr: dstRes  !
  305.     loop
  306. \ Now we create the new version resource which has a "type" that is the
  307. \ same as the sig, and ID 0.
  308.     sig  0  set: dstRes
  309.     4 getText: iDlg  dup 1+ align  new: dstRes
  310.     str255  ptr: dstRes  over  c@ 1+ cMove
  311.     nullOSstr  addRes: dstRes
  312. \ Now copy the Alert" stuff if we need it
  313.     $alq sfind nip
  314.     if    'type ALRT  900  copyRes
  315.         'type DITL  900  copyRes
  316.     then  ;
  317.  
  318. : DOINSTALL
  319.     openMR   getnew: iDlg   getR
  320.     " go"     10 putText: iDlg
  321.     " crash" 11 putText: iDlg
  322.     0 $ ffff 3 setSelect: iDlg
  323.     modal: iDlg
  324.     if    new_application
  325.     then
  326.     close: iDlg
  327.     kludge: instlMod  kludge: pathsmod
  328.     purge            \ Dic image must have no modules loaded
  329.     bye  ;
  330.  
  331.  
  332. : SAVENUC  { \ addr len -- }            \ Saves a new Mops nucleus.
  333.     " Mops.new"  -> len -> addr
  334.     addr len  name: fFcb
  335.     create: fFcb  ?error 169
  336.     addr len  str255            \ Create res file for new nuc
  337.     call CreateResFile
  338.     word0  call reserror  i->l  ?error 169
  339.     ['] nogo  onError
  340.     0  buf255  call OpenResFile  drop  chk
  341.     'type APPL  'type MOPS  set: fFcb    \ Set type & sig of appl
  342.     $ 21  fFcb $ 28 + c!            \ Set Bundle bit
  343.     setFileInfo: fFcb
  344.     'type WIND  256  copyRes        \ Copy fWind (WIND 256)
  345.     'type BNDL  128  copyRes        \ And don't drop our BNDL (128)
  346.     132 128 do
  347.         'type ICN#  i  copyRes    \ Copy ICN# and icl8 resources
  348.         'type icl8  i  copyRes
  349.     loop
  350.     'type ics8  128  copyRes        \ And we have one ics8 resource too
  351.     132 128 do
  352.         'type FREF  i  copyRes    \ Copy FREFs
  353.     loop
  354.  
  355.     'type SIZE  -1  copyRes        \ And SIZE -1
  356.     'type ALRT 900  copyRes        \ And ALRT and DITL for alert"
  357.     'type DITL 900  copyRes
  358. \ Now we create the new version resource whose text we get from STR 50.
  359.     'type STR  50  set: srcRes  getNew: srcRes
  360.     ptr: srcRes  size: srcRes  put: $tmp
  361.     'type MOPS  0  set: dstRes
  362.     len: $tmp  dup align  new: dstRes
  363. \    get: $tmp  str255  ptr: dstRes  over  c@ 1+ cMove
  364.     ptr: $tmp  ptr: dstRes  len: $tmp  cmove
  365.     release: $tmp
  366.     nullOSstr  addRes: dstRes
  367.     saveCode            \ Add code resources
  368.     bye  ;                \ That's all, folks
  369.  
  370.  
  371. \            =======================
  372.  
  373. true    value    ICURS
  374.  
  375. \ scroll bars for Stack and Dictionary headroom
  376.  
  377. vScroll    VS1        180 15 48  init: vs1
  378. vScroll    VS2        180 85 48  init: vs2
  379.  
  380. control SAVEBTN
  381. control INSTBTN
  382. control CANBTN
  383. control HEAPBTN
  384.  
  385. \ We'll do one button the "new way":
  386. radioButton    mxSt        197 14  " ++"   init: mxSt
  387.  
  388. control miSt  radioID  init: miSt
  389. control mxDi  radioID  init: mxDi
  390. control miDi  radioID  init: miDi
  391.  
  392. \ Rectangles for formatting screen
  393.  
  394. rect stRect    20 29 170 49  put: stRect    \ stack headroom
  395. rect hpRect    20 64 170 84  put: hpRect    \ heap start size
  396. rect diRect    20 99 170 119  put: diRect    \ Dictionary headroom
  397.     
  398. rect wRect    100 40 400 210 put: wRect
  399.  
  400. \ get current limits for stack and dict based on minHeap
  401.  
  402. : MAXSTACK  curStack curHeap minHeap - +  ;
  403. : MAXDICT   curDict  curHeap minHeap - +  ;
  404.  
  405. 20000    value    MINSTACK
  406.   128    value    MINDICT
  407.  
  408. : .VAL  { n theRect -- }    \ print number in rect
  409.     theRect ->: tempRect
  410.     4 4 inset: tempRect 100 putTopX: tempRect clear: tempRect
  411.     104 getboty: tempRect 2- gotoxy n 7  .r  ;
  412.  
  413. : .VS1    curStack stRect .val curHeap hpRect .val  ;
  414. : .VS2    curDict  diRect .val curHeap hpRect .val  ;
  415.  
  416. :a  DRAWIWIND
  417.     draw: stRect draw: hpRect draw: diRect
  418.     2 tmode 0 tfont 12 tsize
  419.     24 43 gotoxy ." Stack:"
  420.     24 78 gotoxy ." Heap:"
  421.     24 113 gotoxy ." Dictionary:"  .vs1 .vs2   ;a
  422.  
  423. \ Define the Install utility window
  424.  
  425. window+        IWIND
  426. view        IVIEW
  427.  
  428. CFAS{ null null drawIwind null }  actions: iWind
  429.  
  430. : LISTENER    \ Listens to mouse and drops keys
  431.     begin  key drop  again  ;
  432.  
  433. \ Create new window, controls
  434.  
  435. : INSTALL
  436.     vs1  addCtl: iView   vs2  addCtl: iView
  437.     mxSt  addCtl: iView
  438.     wRect "  " dlgWind true false  iView  new: iWind
  439.     2000 32000 putRange: vs1  0 8000 putRange: vs2
  440.     4000 dup put: vs1  put: vs2
  441.     stkspace -> curStack  dicsize -> curDict
  442.     197 46 " --"        iView    new: miSt
  443.     197 84 " ++"        iView    new: mxDi
  444.     197 116 " --"        iView    new: miDi
  445.     238 20 " Save"        iView    new: saveBtn
  446.     236 45 " Install"    iView    new: instBtn
  447.     236 70 " Cancel"    iView    new: canBtn
  448.     150 145 " Max Heap"    iView    new: heapBtn
  449.     -curs   draw: iWind
  450.     begin  key drop  again  ;
  451.  
  452. : stDn    curStack 8 -  minStack max -> curStack  .vs1  ;
  453. : stUp    curStack 8 +  maxStack min -> curStack  .vs1  ;
  454.  
  455. : diDn    curDict 32 -  minDict max -> curDict  .vs2  ;
  456. : diUp    curDict 32 +  maxDict min -> curDict  .vs2  ;
  457.  
  458. CFAS(  stUp stDn null null null  )  actions: vs1
  459. CFAS(  diUp diDn null null null  )  actions: vs2
  460.  
  461.  
  462. : CONFIG        close: iWind  setMem  saveNuc  ;
  463. : WINSTALL    close: iWind  setMem  doInstall  ;
  464. : CANCEL        close: iWind  drop: instlmod  icurs -> curs  quit  ;
  465.  
  466. : DOMXST        curStack 4096 + maxStack min -> curStack .vs1  ;
  467. : DOMIST        curStack 4096 - minStack max -> curStack .vs1  ;
  468. : DOMXDI        curDict 16384 + maxDict min -> curDict .vs2  ;
  469. : DOMIDI        curDict 16384 - minDict max -> curDict .vs2  ;
  470. : DOMXHP        minStack -> curStack .vs1  minDict -> curDict .vs2  ;
  471.  
  472. ' config   actions: saveBtn
  473. ' wInstall actions: instBtn
  474. ' cancel   actions: canBtn
  475. ' doMxSt   actions: mxSt
  476. ' doMiSt   actions: miSt
  477. ' doMxDi   actions: mxDI
  478. ' doMiDi   actions: miDi
  479. ' doMxHp   actions: heapBtn
  480.  
  481. endload                    \ ***
  482.  
  483. \ testing
  484.  
  485. true  setinstall: testmod
  486. compile: testmod
  487.  
  488. 20000 allot
  489.  
  490. : go
  491.     10 0 DO  ." hello there!!"  cr  LOOP
  492.     bb  .mods
  493.     500000 0 DO LOOP
  494.     bye  ;
  495.  
  496. : crash    cr cr ." Oh no!!!"
  497.     500000 0 DO LOOP  bye  ;
  498.